home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / proc.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  38KB  |  1,163 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "libhdr.h"
  14. #include "vars.h"
  15. #include "segment.h"
  16. #include "gvars.h"
  17. #include "ops.h"
  18. #include "type.h"
  19. #include "axqrp.h"
  20. #include "namp.h"
  21. #include "maincasp.h"
  22. #include "exprp.h"
  23. #include "dbxp.h"
  24. #include "miscp.h"
  25. #include "libp.h"
  26. #include "statp.h"
  27. #include "setp.h"
  28. #include "genp.h"
  29. #include "segmentp.h"
  30. #include "gmiscp.h"
  31. #include "smiscp.h"
  32. #include "gutilp.h"
  33. #include "procp.h"
  34.  
  35. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  36.  
  37.  
  38. void gen_subprogram_spec(Node proc_node)                /*;gen_subprogram_spec*/
  39. {
  40.     /* subprogram spec.
  41.      * Just reserve a code slot, and GENERATE the procedure object.
  42.      * If the spec occurs elsewhere than immediately in the declarative part
  43.      * of a compilation unit, it may need a relay set, but we don't know it
  44.      * yet. So, we must prepare for a dynamically elaborated procedure.
  45.      */
  46.  
  47.     int     save_current_code_segment;
  48.     Symbol    proc_name;
  49.     Tuple    predef_tuple;
  50.  
  51. #ifdef TRACE
  52.     if (debug_flag)
  53.         gen_trace_node("GEN_SUBPROGRAM_SPEC", proc_node);
  54. #endif
  55.  
  56.     proc_name   = N_UNQ(proc_node);
  57.     /*tag         = NATURE(proc_name);*/
  58.  
  59.     predef_tuple = (Tuple) MISC(proc_name);
  60.     if (predef_tuple != (Tuple)0) { /*predef */
  61.     }
  62.     else {
  63.         save_current_code_segment = CURRENT_CODE_SEGMENT;
  64.         CURRENT_CODE_SEGMENT = select_entry(SELECT_CODE, proc_name, SLOTS_CODE);
  65. #ifdef TRACE
  66.         if (list_code) {
  67.             to_gen(" ");
  68.             to_gen_unam("--------------------------------------",
  69.                 ORIG_NAME(proc_name), "--------------");
  70.             to_gen_int("     code slot # ", CURRENT_CODE_SEGMENT);
  71.             to_gen(" ");
  72.         }
  73. #endif
  74.  
  75.         if (CURRENT_LEVEL == 1) { /* No relay set needed */
  76.             next_global_reference_r(proc_name, CURRENT_CODE_SEGMENT, 0);
  77.         }
  78.         else {
  79.             next_local_reference(proc_name);
  80.         }
  81.         /* Empty segment */
  82.         CODE_SEGMENT_MAP = segment_map_put(CODE_SEGMENT_MAP,
  83.           CURRENT_CODE_SEGMENT, segment_new(SEGMENT_KIND_CODE, 0));
  84.         SPECS_DECLARED += 1;
  85.         if (!tup_mem((char *) proc_name, SUBPROG_SPECS)) {
  86.             SUBPROG_SPECS = tup_with(SUBPROG_SPECS, (char *) proc_name);
  87.         }
  88. #ifdef MACHINE_CODE
  89.         if (list_code) {
  90.             to_gen_unam("-------- end  ", ORIG_NAME(proc_name), 
  91.                 " -----------");
  92.         }
  93. #endif
  94.         CURRENT_CODE_SEGMENT = save_current_code_segment;
  95.         if (CURRENT_LEVEL != 1) {
  96.             gen(I_END);          /* Purge peep-hole */
  97.             subprog_patch_put(proc_name, PC() + 1);
  98.             gen_rc(I_PUSH_EFFECTIVE_ADDRESS, explicit_ref_0,
  99.               "subprog. template");
  100.             gen(I_CREATE_STRUC);
  101.             gen_s(I_UPDATE_AND_DISCARD, proc_name);
  102.         }
  103.     } /* PREDEF */
  104. }
  105.  
  106. /* Procedure elaboration */
  107.  
  108. void gen_subprogram(Node proc_node)                        /*;gen_subprogram*/
  109. {
  110.     /*
  111.      *   To generate code there are several delicate steps to perform, as
  112.      *   the output of that is not only the proper code to elaborate the
  113.      *   subprogram (which may even be reduced to nothing), but to produce
  114.      *   a new code statement, adding some information to the previous
  115.      *   code generation environment, and preserving the previous
  116.      *   environment by "burying" it in local variables.
  117.      *
  118.      *   Here is a summary of the steps for this procedure:
  119.      *
  120.      *   1) Assign a code slot number to the new procedure/function.
  121.      *      Note: if the corresponding subprogram spec has been compiled, the
  122.      *            code slot is already defined.
  123.      *
  124.      *   2) The relay set must be build. The current relay set is preserved,
  125.      *      and a variable is put into the relay set when it cannot be found
  126.      *      neither in the global nor the local reference map.
  127.      *
  128.      *   3) Compute offsets for the parameters, including offset for the
  129.      *      types of arrays, and for the value returned by a function.
  130.      *      The parameters are located below the stack frame pointer, but
  131.      *      room shall be left for the return informations
  132.      *
  133.      *   4) After preserving the previous environment, generate code for
  134.      *      the procedure/function in a new clean segment, starting with
  135.      *      the "catch-all" exception handler.
  136.      *
  137.      *   5) generate code to elaborate the procedure/function (if not
  138.      *      static)
  139.      *
  140.      *   6) restore previous environment
  141.      */
  142.  
  143.     Node     decl_node, stmt_node, handler_node;
  144.     Symbol    proc_name, fname, ftype, t_name, temp_name, name;
  145.     int        tag, fmode, save_current_code_segment;
  146.     int        simple_recursive_proc, has_separate_spec;
  147.     int        const_addr_size, parameter_offset;
  148.     unsigned int    location; /*OFFSET */
  149.     Fortup    ft1;
  150.     int        proc_code_segment, patch_addr;
  151.     Tuple    save_local_reference_map, save_relay_set, save_subprog_specs;
  152.     unsigned int    save_last_offset, save_max_offset;
  153.     Tuple    save_parameter_set, save_code_patch_set, save_data_patch_set;
  154.     Tuple    temp_relay_set, relay_table;
  155.     Segment    tseg, save_code_segment;
  156.     unsigned int roff;
  157.     int        i, dn, rn;
  158.     struct tt_subprog *tptr;
  159.  
  160.     const_addr_size = mu_size(mu_addr);
  161.     gen(I_END);  /* purge peep-hole buffer */
  162.  
  163.     /*
  164.      *-----
  165.      *  1.
  166.      */
  167.     stmt_node = N_AST1(proc_node);
  168.     decl_node = N_AST2(proc_node);
  169.     proc_name = N_UNQ(proc_node);
  170.     handler_node = N_AST4(proc_node);
  171.     tag         = NATURE(proc_name);
  172.  
  173. #ifdef TRACE
  174.     if (debug_flag)
  175.         gen_trace_symbol("GEN_SUBPROGRAM", proc_name);
  176. #endif
  177.  
  178.     /*
  179.      *-----
  180.      *  2.
  181.      */
  182.  
  183.     save_relay_set           = RELAY_SET;
  184.     save_local_reference_map = LOCAL_REFERENCE_MAP;
  185.     save_subprog_specs       = SUBPROG_SPECS;
  186.     save_last_offset         = LAST_OFFSET;
  187.     save_max_offset          = MAX_OFFSET;
  188.     save_parameter_set       = PARAMETER_SET;
  189.     save_code_patch_set      = CODE_PATCH_SET;
  190.     save_data_patch_set      = DATA_PATCH_SET;
  191.     save_code_segment        = CODE_SEGMENT;
  192.     save_current_code_segment= CURRENT_CODE_SEGMENT;
  193.  
  194.     RELAY_SET           = tup_new(0);
  195.     LOCAL_REFERENCE_MAP = tup_new(0);
  196.     SUBPROG_SPECS       = tup_new(0);
  197.     LAST_OFFSET         = -SFP_SIZE;
  198.     MAX_OFFSET          = 0;
  199.     PARAMETER_SET       = tup_new(0);
  200.     CODE_PATCH_SET      = tup_new(0);
  201.     DATA_PATCH_SET      = tup_new(0);
  202.     CODE_SEGMENT        = segment_new(SEGMENT_KIND_CODE, 0);
  203.     if (is_defined(proc_name)) { /* exists separate subprog spec */
  204.         CURRENT_CODE_SEGMENT = select_entry(SELECT_CODE, proc_name,
  205.           SLOTS_CODE_BORROWED);
  206.     }
  207.     else {
  208.         CURRENT_CODE_SEGMENT = select_entry(SELECT_CODE, proc_name, SLOTS_CODE);
  209.     }
  210.  
  211.     parameter_offset = -const_addr_size;
  212.     FORTUP(fname = (Symbol), SIGNATURE(proc_name), ft1);
  213.         fmode = NATURE(fname);
  214.         ftype = TYPE_OF(fname);
  215.         if (!tup_mem((char *)fname, PARAMETER_SET)) {
  216.             PARAMETER_SET = tup_with(PARAMETER_SET, (char *) fname);
  217.         }
  218.         if (is_array_type(ftype)) {
  219.             /* Array addresses are mu_dble */
  220.             /*t_name= fname+'_type'; $ associate name*/
  221.             t_name= new_unique_name("fname_type");
  222.             assoc_symbol_put(fname, FORMAL_TEMPLATE, t_name);
  223.             local_reference_map_put(t_name, parameter_offset);
  224.             parameter_offset           -= const_addr_size;
  225.             if (!tup_mem((char *) t_name, PARAMETER_SET)) {
  226.                 PARAMETER_SET = tup_with(PARAMETER_SET, (char *) t_name);
  227.             }
  228.         }
  229.         local_reference_map_put(fname, (int) parameter_offset);
  230.         parameter_offset          -= const_addr_size;
  231.         if ((is_simple_type(ftype) &&  (fmode != na_in))) {
  232.             /* scalar out and in out parameters takes 2 stacks locations */
  233.             /* one for returned na_out value, the other for temporary na_in */
  234.             parameter_offset -= const_addr_size;
  235.         }
  236.     ENDFORTUP(ft1);
  237.  
  238.     if (tag == na_function ||
  239.       tag == na_function_spec  ) { /* temporary kludge */
  240.         parameter_offset = parameter_offset + const_addr_size
  241.           - mu_size(kind_of(TYPE_OF(proc_name)));
  242.         t_name = new_unique_name("return_temp");
  243.         /* associated name */
  244.         assoc_symbol_put(proc_name, RETURN_TEMPLATE, t_name);
  245.         generate_object(t_name);
  246.         if (!tup_mem((char *)t_name, PARAMETER_SET)) {
  247.             PARAMETER_SET  = tup_with(PARAMETER_SET, (char *) t_name);
  248.         }
  249.         local_reference_map_put(t_name, (int) parameter_offset);
  250.     }
  251.  
  252. #ifdef MACHINE_CODE
  253.     if (list_code) {
  254. #ifdef TBSN
  255.         f_name = formatted_name([tag, proc_name]);
  256. #endif
  257.         to_gen(" ");
  258.         to_gen_unam("-----------------------------",
  259.             ORIG_NAME(proc_name), "-------------------");
  260.         to_gen_int("     code slot # ", CURRENT_CODE_SEGMENT);
  261.         to_gen(" ");
  262.     }
  263. #endif
  264.     /* "catch-all exception handler" */
  265.     gen(I_LEAVE_BLOCK);
  266.     gen(I_RAISE);
  267.     if (tag == na_task_body) {
  268.         /* task trap */
  269.         gen_ic(I_TERMINATE, 2, "task trap");
  270.     }
  271.  
  272.     compile_body(decl_node, stmt_node, handler_node, FALSE);
  273.  
  274.     MAX_OFFSET = offset_max(MAX_OFFSET, LAST_OFFSET);
  275.     /* GBSL: see if offset in next op in bytes or needs adjustment */
  276.     gen_ic(I_DATA, MAX_OFFSET-SFP_SIZE, "size of local objects");/*GBSL*/
  277.     gen(I_END);
  278.  
  279. #ifdef MACHINE_CODE
  280.     if (list_code) {
  281.         to_gen(" ");
  282.         to_gen(" --- Local reference map :");
  283.         to_gen_int("    Parameter offset = ", MAX_OFFSET);
  284.         print_ref_map_local();
  285.         /*TO_GEN("-------- end of '+f_name+' -----------");*/
  286.         to_gen("-------- end -----------");
  287.     }
  288. #endif
  289.  
  290.     /*
  291.      *  The set of local variables for the compiled subprogram is now
  292.      *  complete, therefore we can patch the addresses of the parameters.
  293.      */
  294.  
  295.     FORTUP(location = (unsigned), CODE_PATCH_SET, ft1);
  296.         update_code((int) location, MAX_OFFSET);
  297.     ENDFORTUP(ft1);
  298.     FORTUP(location = (unsigned), DATA_PATCH_SET, ft1);
  299.         segment_put_off(DATA_SEGMENT, location, 
  300.           segment_get_off(DATA_SEGMENT, (int) location) - MAX_OFFSET);
  301.     ENDFORTUP(ft1);
  302.     /* Note: as this subprogram is not a compilation unit, it cannot */
  303.     /* contain stubs. The following serves only for the printout of */
  304.     /* LOCAL_REFERENCE_MAP: */
  305.     FORTUP(name = (Symbol), PARAMETER_SET, ft1);
  306.         local_reference_map_put(name, local_reference_map_get(name)-MAX_OFFSET);
  307.     ENDFORTUP(ft1);
  308.     CODE_SEGMENT_MAP = segment_map_put(CODE_SEGMENT_MAP, CURRENT_CODE_SEGMENT,
  309.       CODE_SEGMENT);
  310.     temp_relay_set       = RELAY_SET;
  311.     CODE_SEGMENT         = save_code_segment;
  312.     proc_code_segment    = CURRENT_CODE_SEGMENT;
  313.     CURRENT_CODE_SEGMENT = save_current_code_segment;
  314.     CODE_PATCH_SET       = save_code_patch_set;
  315.     DATA_PATCH_SET       = save_data_patch_set;
  316.     PARAMETER_SET        = save_parameter_set;
  317.     LOCAL_REFERENCE_MAP  = save_local_reference_map;
  318.     LAST_OFFSET          = save_last_offset;
  319.     SUBPROG_SPECS        = save_subprog_specs;
  320.     RELAY_SET            = save_relay_set;
  321.     MAX_OFFSET           = save_max_offset;
  322.  
  323.     /*
  324.      * Now, considering the content of the relay-set, plus the fact that we
  325.      * may have already decided that the subprogram object is local, we
  326.      * can proceed to the elaboration of the subprogram.
  327.      */
  328.  
  329.     simple_recursive_proc =
  330.       (tup_size(temp_relay_set) == 1 && proc_name == (Symbol)temp_relay_set[1]);
  331.     has_separate_spec = tup_mem((char *) proc_name,  SUBPROG_SPECS);
  332.     if ((tup_size(temp_relay_set) == 0 || simple_recursive_proc)
  333.       && ! has_separate_spec) {
  334.         /* next_global_reference(proc_name,
  335.          *  [proc_code_segment,
  336.          *  simple_recursive_proc ? 1 : 0]);
  337.          */
  338.         tseg = segment_new(SEGMENT_KIND_DATA, 2);
  339.         segment_set_pos(tseg, 0, 0); /* reposition to start */
  340.         segment_put_word(tseg, proc_code_segment);
  341.         segment_put_word(tseg, simple_recursive_proc != 0 ? 1 : 0 );
  342.         next_global_reference_segment(proc_name, tseg);
  343.         segment_free(tseg);
  344.         if (simple_recursive_proc) {
  345.             reference_of(proc_name);
  346.             segment_put_int(DATA_SEGMENT, REFERENCE_SEGMENT);
  347.             segment_put_int(DATA_SEGMENT, (int) REFERENCE_OFFSET);
  348.             /*DATA_SEGMENT += reference_of(proc_name);*/
  349.         }
  350.     }
  351.     else if (CURRENT_LEVEL == 1) {
  352.         if (tup_size(temp_relay_set) != 0 || simple_recursive_proc) {
  353. #ifdef DEBUG
  354.             FORTUP(name = (Symbol), temp_relay_set, ft1);
  355.                 zpsym(name);
  356.             ENDFORTUP(ft1);
  357. #endif
  358.             chaos("Relay set at level 1");
  359. #ifdef TRACE
  360.             if (debug_flag)
  361.                 gen_trace_symbols("GEN_SUBPROGRAM", temp_relay_set);
  362. #endif
  363.             return;
  364.         }
  365.     }
  366.     else {
  367.         if (! has_separate_spec) {
  368.             next_local_reference(proc_name);
  369.             gen(I_END);          /* Purge peep-hole */
  370.             subprog_patch_put(proc_name, PC() + 1);
  371.             gen_rc(I_PUSH_EFFECTIVE_ADDRESS, explicit_ref_0,
  372.               "subprogram template");
  373.             gen(I_CREATE_STRUC);
  374.             gen_s(I_UPDATE_AND_DISCARD, proc_name);
  375.         }
  376.  
  377.         /* Build subprogram template. The call to reference_of will */
  378.         /* automatically add to the current relay set objects in */
  379.         /* temp_relay_set not already in it. If current parameters are */
  380.         /* referred, care must be taken to patch the address in the data */
  381.         /* segment and not at the current position in the code segment. */
  382.  
  383.         /* Use PROC_TEMPLATE if defined (as can be the case for stubs),
  384.          * otherwise, create PROC_TEMPLATE symbol.
  385.          */
  386.         if (assoc_symbol_exists(proc_name, PROC_TEMPLATE)) {
  387.             temp_name = assoc_symbol_get(proc_name, PROC_TEMPLATE);
  388.         }
  389.         else { /* otherwise create new symbol and use it for template */
  390.             temp_name = new_unique_name(":proc_template");
  391.             assoc_symbol_put(proc_name, PROC_TEMPLATE, temp_name);
  392.             generate_object(temp_name);
  393.         }
  394.         relay_table = tup_new(0);
  395.         FORTUP(name = (Symbol), temp_relay_set, ft1);
  396.             if (tup_mem((char *) name, PARAMETER_SET)) {
  397.                 relay_table  =  tup_with(relay_table, (char *)
  398.                 local_reference_map_get(name));
  399.                 /*DATA_PATCH_SET with= #DATA_SEGMENT + 4 + #relay_table;*/
  400. #ifdef TBSN
  401.                 DATA_PATCH_SET = tup_with(DATA_PATCH_SET, (char *)
  402.                 DATA_SEGMENT->seg_maxpos-1);
  403.                 /* TBSL
  404.                  * Review that 4 is right - it is some sort of offset in data
  405.                  * segment review that getting lastp position in DATA SEGMENT
  406.                  * properly
  407.                  */
  408.                 DATA_PATCH_SET = tup_with(DATA_PATCH_SET, (char *) 4);
  409.                 DATA_PATCH_SET = tup_with(DATA_PATCH_SET,
  410.                   (char *) tup_size(relay_table));
  411. #endif
  412.                 DATA_PATCH_SET = tup_with(DATA_PATCH_SET, (char *)
  413.                 (DATA_SEGMENT->seg_maxpos - 1 + 4 + tup_size(relay_table)) );
  414.             }
  415.             else {
  416.                 reference_of(name);
  417.                 relay_table = tup_with(relay_table, (char *) REFERENCE_OFFSET);
  418.             }
  419.         ENDFORTUP(ft1);
  420.  
  421.         if (is_defined(temp_name)) {
  422.             /* Subprogram template already generated => this a body of a */
  423.             /* proc whose spec has been declared in the visible part of a */
  424.             /* package whose body is separate (the so called HA-HA! case). */
  425.             /*DANGLING_RELAY_SETS += [proc_code_segment, #relay_table] +
  426.               *    relay_table;
  427.               */
  428.             DANGLING_RELAY_SETS = tup_with(DANGLING_RELAY_SETS, (char *)
  429.               proc_code_segment);
  430.             DANGLING_RELAY_SETS = tup_with(DANGLING_RELAY_SETS, 
  431.               (char *) tup_size(relay_table));
  432.             dn = tup_size(DANGLING_RELAY_SETS);
  433.             rn = tup_size(relay_table);
  434.             if (rn != 0) { /* if relay table to append */
  435.                 DANGLING_RELAY_SETS = tup_exp(DANGLING_RELAY_SETS, dn+rn);
  436.                 for (i = 1; i <= rn; i++) {
  437.                     DANGLING_RELAY_SETS[dn+i] = relay_table[i];
  438.                 }
  439.             }
  440.         }
  441.         else {
  442.             /* next_global_reference(temp_name,
  443.               *          [tt_subprog, #relay_table, proc_code_segment, 0]
  444.               *         + relay_table);
  445.               */
  446.             tseg = template_new(TT_SUBPROG, tup_size(relay_table),
  447.               WORDS_SUBPROG, (int **)&tptr);
  448.             tptr->cs = proc_code_segment;
  449.             tptr->relay_slot = 0;
  450.             FORTUP(roff = (unsigned int), relay_table, ft1);
  451.                 segment_put_word(tseg, (int) roff);
  452.             ENDFORTUP(ft1);
  453.             next_global_reference_template(temp_name, tseg);
  454.             segment_free(tseg);
  455.             patch_addr                 = subprog_patch_get(proc_name);
  456.             subprog_patch_undef(proc_name);          /* No more needed */
  457.             gen(I_END); /* flush peep-hole stack before patching */
  458.             reference_of(temp_name);
  459.             /*CODE_SEGMENT(patch_addr)   = REFERENCE_SEGMENT;*/
  460.             patch_code_byte(patch_addr, REFERENCE_SEGMENT);
  461.             patch_code(patch_addr, (int)REFERENCE_OFFSET);
  462.         }
  463.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, temp_name);
  464.         gen_s(I_SUBPROGRAM, proc_name);
  465.     }
  466. }
  467.  
  468. void unit_subprog_spec(Node proc_node)                        /*;subprog_spec*/
  469. {
  470.     /*
  471.      * separatly compiled subprogram spec.
  472.      * Just reserve a code slot and a data slot.
  473.      * The procedure object will be generated by compilation of the body, in
  474.      * order to save one data segment.
  475.      */
  476.  
  477.     Symbol    proc_name;
  478.  
  479. #ifdef TRACE
  480.     if (debug_flag)
  481.         gen_trace_node("UNIT_SUBPROG_SPEC", proc_node);
  482. #endif
  483.  
  484.     proc_name   = N_UNQ(proc_node);
  485.     /*tag         = NATURE(proc_name);*/
  486.  
  487.     CURRENT_DATA_SEGMENT  = select_entry(SELECT_DATA, proc_name, SLOTS_DATA);
  488.     CURRENT_CODE_SEGMENT  = select_entry(SELECT_CODE, proc_name, SLOTS_CODE);
  489. #ifdef MACHINE_CODE
  490.     if (list_code) {
  491.         to_gen_int("     data slot # ", CURRENT_DATA_SEGMENT);
  492.         to_gen_int("     code slot # ", CURRENT_CODE_SEGMENT);
  493.         to_gen(" ");
  494.     }
  495. #endif
  496.  
  497.     next_global_reference_def(proc_name); /* just enter the reference into */
  498.     /* reference table (no relay set) */
  499.     /* Empty segment */
  500.     CODE_SEGMENT_MAP = segment_map_put(CODE_SEGMENT_MAP, CURRENT_CODE_SEGMENT,
  501.       CODE_SEGMENT);
  502. }
  503.  
  504. void unit_subprog(Node proc_node)                            /*;unit_subprog*/
  505. {
  506.     /*
  507.      * Roughly similar to GEN_SUBPROGRAM, but for a compilation unit
  508.      * Beware: if the procedure spec has been separately compiled, the
  509.      *         procedure object has NOT been generated.
  510.      * It may be a task body in the case of a subunit
  511.      */
  512.  
  513.     Node    decl_node, stmt_node, handler_node;
  514.     Symbol    proc_name, fname, ftype, t_name, temp_name, name;
  515.     int        tag, fmode;
  516.     int        stub_cs;
  517.     Fortup    ft1;
  518.     int        parameter_offset, const_addr_size, i, patch_addr, si;
  519.     unsigned int    location;
  520.     Segment    tseg;
  521.     Tuple    local_reference_map_new(), stubtup;
  522.     Stubenv    ev;
  523.     struct tt_subprog *tptr;
  524.  
  525. #ifdef TRACE
  526.     if (debug_flag)
  527.         gen_trace_node("UNIT_SUBPROG", proc_node);
  528. #endif
  529.     const_addr_size = mu_size(mu_addr);
  530.     stmt_node = N_AST1(proc_node);
  531.     decl_node = N_AST2(proc_node);
  532.     proc_name = N_UNQ(proc_node);
  533.     handler_node = N_AST4(proc_node);
  534.     tag         = NATURE(proc_name);
  535.  
  536.     if (is_subunit(unit_name)) {
  537.         CURRENT_LEVEL = current_level_get(unit_name);
  538.     }
  539.     else {
  540.         CURRENT_LEVEL = 1;
  541.         /* set is_main flag for this unit if it is parameterless. 
  542.          * it is already known that it is a subprogram which is not a subunit
  543.          */
  544.         pUnits[unit_number_now]->isMain = (tup_size(SIGNATURE(proc_name)) == 0
  545.           && NATURE(proc_name) == na_procedure);
  546.     }
  547.     LAST_OFFSET         = -SFP_SIZE;
  548.     MAX_OFFSET          = 0;
  549.     RELAY_SET           = tup_new(0);
  550.     CODE_PATCH_SET      = tup_new(0);
  551.     DATA_PATCH_SET      = tup_new(0);
  552.     LOCAL_REFERENCE_MAP = local_reference_map_new();
  553.  
  554.     if (is_subunit(unit_name)) {
  555.         CURRENT_CODE_SEGMENT = select_entry(SELECT_CODE, proc_name,
  556.           SLOTS_CODE_BORROWED);
  557.         CURRENT_DATA_SEGMENT = select_entry(SELECT_DATA, proc_name,
  558.           SLOTS_DATA);
  559.     }
  560.     else if (is_defined(proc_name)) {     /* separately compiled spec */
  561.         CURRENT_CODE_SEGMENT = select_entry(SELECT_CODE, proc_name,
  562.           SLOTS_CODE_BORROWED);
  563.         CURRENT_DATA_SEGMENT = select_entry(SELECT_DATA, proc_name,
  564.           SLOTS_DATA_BORROWED);
  565.     }
  566.     else {
  567.         CURRENT_CODE_SEGMENT = select_entry(SELECT_CODE, proc_name, SLOTS_CODE);
  568.         CURRENT_DATA_SEGMENT = select_entry(SELECT_DATA, proc_name, SLOTS_DATA);
  569.     }
  570.     if (! is_subunit(unit_name)) { /* procedure object and template */
  571.         /* already generated for stubs */
  572.         next_global_reference_r(proc_name, CURRENT_CODE_SEGMENT, 0);
  573.     }
  574. #ifdef MACHINE_CODE
  575.     if (list_code) {
  576.         to_gen_int("     data slot # ", CURRENT_DATA_SEGMENT);
  577.         to_gen_int("     code slot # ", CURRENT_CODE_SEGMENT);
  578.         to_gen(" ");
  579.     }
  580. #endif
  581.     parameter_offset = -const_addr_size;
  582.     FORTUP( fname = (Symbol), SIGNATURE(proc_name), ft1);
  583.         fmode = NATURE(fname);
  584.         ftype = TYPE_OF(fname);
  585.         if (is_array_type(ftype)) {
  586.             /* Array addresses are mu_dble */
  587.             t_name = new_unique_name("formal_temp"); /* associated_name */
  588.             assoc_symbol_put(fname, FORMAL_TEMPLATE, t_name);
  589.             local_reference_map_put(t_name, parameter_offset);
  590.             parameter_offset -= const_addr_size;
  591.             if (!tup_mem((char *)t_name, PARAMETER_SET)) {
  592.                 PARAMETER_SET = tup_with(PARAMETER_SET, (char *) t_name);
  593.             }
  594.         }
  595.         local_reference_map_put(fname, parameter_offset);
  596.         if (!tup_mem((char *) fname, PARAMETER_SET)) {
  597.             PARAMETER_SET = tup_with(PARAMETER_SET, (char *) fname);
  598.         }
  599.         parameter_offset -= const_addr_size;
  600.         if ((is_simple_type(ftype) && (fmode != na_in))) {
  601.             /* scalar out and in out parameters takes 2 stacks locations */
  602.             /* one for returned na_out value, the other for temporary na_in */
  603.             parameter_offset -= const_addr_size;
  604.         }
  605.     ENDFORTUP(ft1);
  606.     if (tag == na_function
  607.       || tag == na_function_spec ) {/* to be removed when tag ok for stubs */
  608.         parameter_offset = parameter_offset+const_addr_size
  609.           - mu_size(kind_of(TYPE_OF(proc_name)));
  610.         t_name = new_unique_name("return_temp");
  611.         /* associated name*/
  612.         assoc_symbol_put(proc_name, RETURN_TEMPLATE, t_name);
  613.         generate_object(t_name);
  614.         if (!tup_mem((char *)t_name, PARAMETER_SET))
  615.             PARAMETER_SET = tup_with(PARAMETER_SET, (char *) t_name);
  616.         local_reference_map_put(t_name, parameter_offset);
  617.     }
  618.  
  619.     gen(I_LEAVE_BLOCK);
  620.     gen(I_RAISE);
  621.     if (tag == na_task_body) {
  622.         /* task trap */
  623.         gen_ic(I_TERMINATE, 2, "task trap");
  624.     }
  625.     compile_body(decl_node, stmt_node, handler_node, FALSE);
  626.  
  627.     /* MAX_OFFSET max= abs LAST_OFFSET;*/
  628.     MAX_OFFSET = offset_max(MAX_OFFSET, LAST_OFFSET);
  629.     /* GBSL see if 2nd arg in next op in bytes or if needs adjustment */
  630.     gen_ic(I_DATA, MAX_OFFSET-SFP_SIZE, "size of local objects");/*GBSL*/
  631.     gen(I_END);
  632.  
  633.     /*  The set of local variables for the compiled subprogram is now
  634.      *  complete, therefore we can patch the addresses of the parameters.
  635.      *  we must update local_reference_map also as it will be reused by
  636.      *  the subunits.
  637.      */
  638.     FORTUP(location = (unsigned), CODE_PATCH_SET, ft1);
  639.         update_code((int) location, MAX_OFFSET);
  640.     ENDFORTUP(ft1);
  641.     FORTUP(location = (unsigned), DATA_PATCH_SET, ft1);
  642.         segment_put_off(DATA_SEGMENT, location, 
  643.           segment_get_off(DATA_SEGMENT, location) - MAX_OFFSET);
  644.     ENDFORTUP(ft1);
  645.     FORTUP(name = (Symbol), PARAMETER_SET, ft1);
  646.         local_reference_map_put(name, local_reference_map_get(name)-MAX_OFFSET);
  647.     ENDFORTUP(ft1);
  648.  
  649.     if (is_subunit(unit_name)) {
  650.         si = stub_numbered(unit_name);
  651.         stubtup = (Tuple) stub_info[si];
  652.         ev = (Stubenv) stubtup[2];
  653.         ev->ev_relay_set = RELAY_SET; /* TBSL - is copy needed ? */
  654.         ev->ev_dangling_relay_set = tup_new(0);
  655.         if (tup_size(DANGLING_RELAY_SETS) != 0) {
  656.             /* should happen only with packages */
  657.             compiler_error("Dangling relay set at level 1");
  658. #ifdef TRACE
  659.             if (debug_flag)
  660.                 gen_trace_symbols("UNIT_SUBPROG", DANGLING_RELAY_SETS);
  661. #endif
  662.         }
  663.     }
  664.     else if (tup_size(RELAY_SET) != 0 || tup_size(DANGLING_RELAY_SETS) != 0) {
  665. #ifdef DEBUG
  666.         printf("relay set\n");
  667.         FORTUP(name = (Symbol), RELAY_SET, ft1);
  668.             zpsym(name);
  669.         ENDFORTUP(ft1);
  670.         printf("dangling relay sets\n");
  671.         zptup(DANGLING_RELAY_SETS);
  672. #endif
  673.         chaos("Relay set at level 1");
  674. #ifdef TRACE
  675.         if (debug_flag) {
  676.             gen_trace_symbols("UNIT_SUBPROG (RELAY SET)", RELAY_SET );
  677.             gen_trace_symbols("UNIT_SUBPROG (DANGLING_RELAY_SETS)" ,
  678.               DANGLING_RELAY_SETS);
  679.         }
  680. #endif
  681.     }
  682.  
  683.     /* Remaining elements in SUBPROG_PATCH are procedures declared in a */
  684.     /* package spec whose body is separate. Generate corresponding */
  685.     /* procedure templates. Those templates must be declared as */
  686.     /* generated objects, as they will be referenced by other units. */
  687.     /* Information in symbol tables is irrelevant, and left as OM. */
  688.     gen(I_END); /* flush peep-hole stack before patching */
  689.     for (i = 1; i <= tup_size(SUBPROG_PATCH); i += 2) {
  690.         name = (Symbol) SUBPROG_PATCH[i];
  691.         patch_addr = (int) SUBPROG_PATCH[i+1];
  692.         temp_name = new_unique_name("proc_temp");
  693.         /* associated name */
  694.         assoc_symbol_put(name, PROC_TEMPLATE, temp_name);
  695.         generate_object(temp_name);
  696.         stub_cs = select_entry(SELECT_CODE, name, SLOTS_CODE_BORROWED);
  697.         /* next_global_reference(temp_name, [tt_subprog,
  698.          *                    -1,
  699.          *                    stub_cs,
  700.          *                stub_cs]);  
  701.          */
  702.         tseg = template_new(TT_SUBPROG, -1, WORDS_SUBPROG, (int **)&tptr);
  703.         tptr->cs = stub_cs;
  704.         tptr->relay_slot =  stub_cs; /* relay slot */
  705.         next_global_reference_segment(temp_name, tseg);
  706.         segment_free(tseg);
  707.         reference_of(temp_name);
  708.         patch_code_byte(patch_addr, REFERENCE_SEGMENT);
  709.         patch_code(patch_addr, REFERENCE_OFFSET);
  710.     }
  711.     /* TBSL: JPR indicated SUBPROG_PATCH dead after above loop
  712.      * check this        ds 3-5-85
  713.      */
  714.  
  715.     CODE_SEGMENT_MAP = segment_map_put(CODE_SEGMENT_MAP, CURRENT_CODE_SEGMENT,
  716.       CODE_SEGMENT);
  717.  
  718. #ifdef MACHINE_CODE
  719.     if (list_code) {
  720.         to_gen(" ");
  721.         to_gen(" --- Local reference map :");
  722.         to_gen_int("    Parameter offset = ", MAX_OFFSET);
  723.         print_ref_map_local();
  724.     }
  725. #endif
  726. }
  727.  
  728. /* Parameter passing (Prelude) */
  729.  
  730. void gen_prelude(Symbol proc_name, Node args_node)            /*;gen_prelude*/
  731. {
  732.     Tuple    formals, actuals;
  733.     Node    arg_node, pre_node, addr_node;
  734.     Symbol    fname, ftype, arg_name, arg_type, qual_arg_type, addr_type;
  735.     Symbol    a_temp, f_temp;
  736.     int        fmode, nk;
  737.     Fortup    ft1;
  738.  
  739. #ifdef TRACE
  740.     if (debug_flag) {
  741.         gen_trace_symbol("GEN_PRELUDE_P", proc_name);
  742.         gen_trace_node("GEN_PRELUDE_A", args_node);
  743.     }
  744. #endif
  745.     formals   = tup_copy(SIGNATURE(proc_name));
  746.     actuals   = tup_copy(N_LIST(args_node));
  747.     /* tup_copy above needed due to use of tup_frome below */
  748.     while (tup_size(formals)) {
  749.         fname = (Symbol) tup_frome(formals);
  750.         fmode = NATURE(fname);
  751.         ftype = TYPE_OF(fname);
  752.         arg_node = (Node) tup_frome(actuals);
  753.  
  754.         while (N_KIND(arg_node) == as_insert) {
  755.             FORTUP(pre_node = (Node), N_LIST(arg_node), ft1);
  756.                 compile(pre_node);
  757.             ENDFORTUP(ft1);
  758.             arg_node = N_AST1(arg_node);
  759.         }
  760.  
  761.         if ((arg_node == OPT_NODE) || (N_KIND (arg_node) == as_raise)) {
  762.             /* Special case: address of arg already on tos. Used for the */
  763.             /* call to the initialization proc of an allocated object. */
  764.             /* the test of raise has been added since the static
  765.              evaluation of the effective parameter may have been 
  766.              transformed as an exception */
  767.             if (N_KIND (arg_node) == as_raise)
  768.                 compile (arg_node); 
  769.             continue;
  770.         }
  771.  
  772.         nk = N_KIND(arg_node);
  773.         qual_arg_type = get_type(arg_node);
  774.  
  775.         /* the qual* must not be removed since they may result from a
  776.          * constraint imposed by the semantic analyser: this is valid for in 
  777.          * parameters
  778.          */
  779.  
  780.         /* To be removed when FE does not emit qual */
  781.         if ((fmode != na_in) && (nk == as_qual_aindex || nk == as_qual_alength
  782.           || nk == as_qual_adiscr || nk == as_qual_range
  783.           || nk == as_qual_index || nk == as_qual_discr || nk == as_qual_sub)) {
  784.             arg_node = N_AST1(arg_node);
  785.         }
  786.  
  787.         arg_name = N_UNQ(arg_node);
  788.         arg_type = get_type(arg_node);
  789.  
  790.         if (is_simple_type(ftype)) {
  791.             /* Scalar, access, or task types. */
  792.             /* For those types, Ada requires that parameter passing is done */
  793.             /* by copy => create a temporary to hold the value. */
  794.  
  795.             if (fmode == na_in) {
  796. #ifdef TBSN
  797.                 if (is_ivalue(arg_node) && !not_included(arg_type, ftype)) {
  798.                     value = get_ivalue(arg_node);
  799.                     /* the argument to get_constant_name must be a Segment, so
  800.                      * must turn result of get_ivalue into a segment ds 6-7-85
  801.                      */
  802.                     seg = segment_new(SEGMENT_KIND_DATA, 1);
  803.                     segment_put_const(seg, value);
  804.                     /*arg_name = get_constant_name(value);*/
  805.                     arg_name = get_constant_name(seg);
  806.                     segment_free(seg);
  807.                     /* useful only for gen_postlude: */
  808.                     N_UNQ(arg_node) = arg_name;
  809.                     /* generate(I_PUSH_EFFECTIVE_ADDRESS, arg_name,
  810.                      *   ' = ' + str value);
  811.                      */
  812.                     gen_s(I_PUSH_EFFECTIVE_ADDRESS, arg_name);
  813.                 }
  814. #endif
  815.                 if (is_simple_name(arg_node) && arg_name != (Symbol)0
  816.                   && NATURE(arg_name) == na_constant && !is_renaming(arg_name)
  817.                   && ! not_included(arg_type, ftype)) {
  818.                     gen_s(I_PUSH_EFFECTIVE_ADDRESS, arg_name);
  819.                 }
  820.                 else {
  821.                     gen_value(arg_node);
  822.                     optional_qual(arg_type, ftype);
  823.                     gen_k(I_CREATE_COPY, kind_of(ftype));
  824.                 }
  825.             }
  826.             else if (fmode == na_inout) {
  827.                 /* a) address and value of the actual */
  828.                 if (N_KIND(arg_node) == as_convert) {
  829.                     addr_node = N_AST2(arg_node);
  830.                     addr_type = get_type(addr_node);
  831.                     gen_address(addr_node);
  832.                     gen_k(I_DUPLICATE, mu_addr);
  833.                     if (is_access_type(ftype)) {
  834.                         /* apply constraint check before (dummy) conversion */
  835.                         gen_k(I_DEREF, kind_of(addr_type));
  836.                         optional_qual(addr_type, ftype);
  837.                         gen_convert(addr_type, ftype) ;
  838.                     }
  839.                     else {
  840.                         /* for numeric types, convert first, then constrain */
  841.                         gen_k(I_DEREF, kind_of(addr_type));
  842.                         gen_convert(addr_type, ftype) ;
  843.                         optional_qual(arg_type, ftype) ;
  844.                     }
  845.                 }
  846.                 else {
  847.                     gen_address(arg_node);
  848.                     gen_k(I_DUPLICATE, mu_addr);
  849.                     gen_k(I_DEREF, kind_of(arg_type));
  850.                     optional_qual(arg_type, ftype);
  851.                 }
  852.  
  853.                 a_temp = new_unique_name("inout_tempo");
  854.                 assoc_symbol_put(fname, ACTUAL_TEMPLATE, a_temp);
  855.                 next_local_reference(a_temp);
  856.  
  857.                 /* c) create a temporary with this value */
  858.                 gen_k(I_CREATE_COPY, kind_of(ftype));
  859.                 gen_s(I_UPDATE, a_temp);
  860.             }
  861.             else if (fmode == na_out) {
  862.                 /* a) address of the actual */
  863.                 if (N_KIND(arg_node) == as_convert) {
  864.                     addr_node = N_AST2(arg_node);
  865.                     gen_address(addr_node);
  866.                 }
  867.                 else {
  868.                     gen_address(arg_node);
  869.                 }
  870.  
  871.                 /* b) create an empty temporary */
  872.                 gen_k(I_CREATE, kind_of(ftype));
  873.             }
  874.  
  875.             /* Structured types */
  876.         }
  877.         else if (is_array_type(ftype)) {
  878.             gen_value(arg_node);
  879.             if (!is_unconstrained(ftype) && ftype != arg_type)
  880.                 gen_s(I_QUAL_INDEX, ftype);
  881.         }
  882.         else if (is_record_type(ftype)) {
  883.             gen_value(arg_node);
  884.  
  885.             if (ftype == arg_type || is_unconstrained(ftype)) {
  886.                 ;
  887.             }
  888.             else if (!is_unconstrained(arg_type)) {
  889.                 if (has_discriminant(arg_type))
  890.                     gen_s(I_QUAL_DISCR, ftype);
  891.             }
  892.             else {
  893.                 /*  there are discriminants */
  894.                 /*  the formal is constrained, */
  895.                 /*  the actual is unconstrained */
  896.                 /*      parameter passing by copy ! */
  897.                 gen_s(I_QUAL_DISCR, ftype);
  898.                 if (fmode == na_inout || fmode == na_out) {
  899.                     if (!assoc_symbol_exists(fname, ACTUAL_TEMPLATE)) {
  900.                         /* Create temporary variables if not done by previous */
  901.                         /* call. */
  902.                         a_temp = new_unique_name("fname_actual");
  903.                         f_temp = new_unique_name("fname_formal");
  904.                         next_local_reference(a_temp);
  905.                         next_local_reference(f_temp);
  906.                         assoc_symbol_put(fname, ACTUAL_TEMPLATE, a_temp);
  907.                         assoc_symbol_put(fname, FORMAL_TEMPLATE, f_temp);
  908.                     }
  909.                     gen_s(I_UPDATE, assoc_symbol_get(fname, ACTUAL_TEMPLATE));
  910.                 }
  911.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, ftype);
  912.                 gen(I_CREATE_COPY_STRUC);
  913.                 if (fmode != na_out) {
  914.                     /* set constrained bit */
  915.                     gen_k(I_DUPLICATE, mu_addr);
  916.                     gen_kv(I_PUSH_IMMEDIATE, kind_of(symbol_boolean),
  917.                       int_const(TRUE));
  918.                     gen_k(I_MOVE, kind_of(symbol_boolean));
  919.                 }
  920.             }
  921.         }
  922.         else {
  923.             compiler_error_s("Prelude, ftype =", ftype);
  924.         }
  925.     }
  926.     tup_free(formals); 
  927.     tup_free(actuals);
  928. }
  929.  
  930. /* Parameter passing (Postlude) */
  931.  
  932. void gen_postlude(Symbol proc_name, Node args_node)            /*;gen_postlude*/
  933. {
  934.     Tuple    formals;
  935.     Tuple    actuals;
  936.     Node    arg_node, addr_node;
  937.     Symbol    fname, ftype, arg_type, addr_type, formal_obj_type,
  938.         actual_obj_type, arg_name;
  939.     int        fmode, nk;
  940.  
  941. #ifdef TRACE
  942.     if (debug_flag) {
  943.         gen_trace_symbol("GEN_POSTLUDE_P", proc_name);
  944.         gen_trace_node("GEN_POSTLUDE_A", args_node);
  945.     }
  946. #endif
  947.  
  948.     formals   = tup_copy(SIGNATURE(proc_name));
  949.     actuals   = tup_copy(N_LIST(args_node));
  950.     /* tup_copy needed above due to use of tup_fromb below */
  951.     while (tup_size(formals)) {
  952.         fname  = (Symbol) tup_fromb(formals);
  953.         fmode   = NATURE (fname);
  954.         ftype   = TYPE_OF(fname);
  955.         arg_node = (Node) tup_fromb(actuals);
  956.  
  957.         while (N_KIND(arg_node) == as_insert)
  958.             arg_node = N_AST1(arg_node);
  959.  
  960.         if (arg_node == OPT_NODE) {
  961.             /* Special case: address was on tos, must stay there. Used for */
  962.             /* the call to the initialization proc of an allocated object. */
  963.             continue;
  964.         }
  965.         nk = N_KIND(arg_node);
  966.         if (nk == as_qual_aindex || nk == as_qual_alength
  967.           || nk == as_qual_adiscr || nk == as_qual_range
  968.           || nk == as_qual_index || nk == as_qual_discr || nk == as_qual_sub) {
  969.             arg_node = N_AST1(arg_node);
  970.         }
  971.  
  972.         arg_type = get_type(arg_node);
  973.  
  974.         /* Scalar or access (or task) types.
  975.          * For those types, ada requires that parameter passing is done by copy,
  976.          * thus for out and inout parameters we must copy-out the result.
  977.          * NB: tasks can be only of mode na_in
  978.          */
  979.  
  980.         if (is_simple_type(ftype)) {
  981.  
  982.             if (fmode == na_in) {
  983.                 /* If possible, retrieve name of argument for the peep-hole */
  984.                 arg_name = N_UNQ(arg_node);
  985. #ifdef TBSL
  986.                 if (is_ivalue(arg_node)) {
  987.                     arg_name = N_UNQ(arg_node);
  988.                     gen_ks(I_DISCARD_ADDR, 1, arg_name);
  989.                 }
  990. #endif
  991.                 if (is_simple_name(arg_node) && arg_name != (Symbol)0
  992.                   && NATURE(arg_name) == na_constant && !is_renaming(arg_name)
  993.                   && ! not_included(arg_type, ftype)) {
  994.                     gen_ks(I_DISCARD_ADDR, 1, arg_name);
  995.                 }
  996.                 else {
  997.                     gen(I_UNCREATE);
  998.                 }
  999.             }
  1000.             else if (fmode == na_inout || fmode == na_out) {
  1001.                 gen_k(I_DEREF, kind_of(ftype));
  1002.                 if (N_KIND(arg_node) == as_convert) {
  1003.                     addr_node = N_AST2(arg_node);
  1004.                     addr_type = get_type(addr_node);
  1005.                     /* On exit, the target type of the conversion is the type
  1006.                      * of the actual, not that of the formal (used below). 
  1007.                      */
  1008.                     arg_type = addr_type ;
  1009.                     gen_convert(ftype, arg_type);
  1010.                     if (!is_access_type(ftype))
  1011.                         gen_s(I_QUAL_RANGE, addr_type);
  1012.                 }
  1013.  
  1014.                 if (is_access_type(ftype) ) {
  1015.                     formal_obj_type = (Symbol) designated_type(ftype);
  1016.                     actual_obj_type = (Symbol) designated_type(arg_type);
  1017.                     if (formal_obj_type != actual_obj_type
  1018.                       && !is_unconstrained(actual_obj_type)) {
  1019.                         if (is_array_type(actual_obj_type) ) {
  1020.                             gen_access_qual(as_qual_index, actual_obj_type);
  1021.                         }
  1022.                         else if (is_record_type(actual_obj_type)) {
  1023.                             gen_access_qual(as_qual_discr, actual_obj_type);
  1024.                         }
  1025.                         else {     /* simple type */
  1026.                             ;  /* No need to qual range */
  1027.                         }
  1028.                     }
  1029.                 }
  1030.                 else if (N_KIND(arg_node) != as_convert
  1031.                   && not_included(ftype, arg_type) ) {
  1032.                     /* never the case for convert */
  1033.                     gen_s(I_QUAL_RANGE, arg_type);
  1034.                 }
  1035.                 gen_k(I_MOVE, kind_of(ftype));
  1036.                 if(fmode == na_inout) {
  1037.                     gen_s(I_PUSH_EFFECTIVE_ADDRESS,
  1038.                       assoc_symbol_get(fname, ACTUAL_TEMPLATE));
  1039.                     gen(I_UNCREATE);
  1040.                 }
  1041.             }
  1042.  
  1043.             /* Structured types */
  1044.         }
  1045.         else if (is_array_type(ftype)) {
  1046.             gen_ks(I_DISCARD_ADDR, 1, arg_type);
  1047.             if (is_simple_name(arg_node) ) {
  1048.                 gen_ks(I_DISCARD_ADDR, 1, N_UNQ(arg_node));
  1049.             }
  1050.             else if (is_ivalue(arg_node)) {
  1051.                 arg_name = get_constant_name(array_ivalue(arg_node));
  1052.                 gen_ks(I_DISCARD_ADDR, 1, arg_name);
  1053.             }
  1054.             else {
  1055.                 gen_ks(I_DISCARD_ADDR, 1, (Symbol)0);
  1056.             }
  1057.         }
  1058.         else if (is_record_type(ftype)) {
  1059.             if (is_unconstrained(ftype) || !is_unconstrained(arg_type)
  1060.               || fmode == na_in ) {
  1061.                 if (is_simple_name(arg_node) ) {
  1062.                     gen_ks(I_DISCARD_ADDR, 1, N_UNQ(arg_node));
  1063.                 }
  1064.                 else if (is_ivalue(arg_node)) {
  1065.                     /* note that record_ivalue returns a segment */
  1066.                     arg_name = get_constant_name(record_ivalue(arg_node));
  1067.                     gen_ks(I_DISCARD_ADDR, 1, arg_name);
  1068.                 }
  1069.                 else {
  1070.                     gen_ks(I_DISCARD_ADDR, 1, (Symbol)0);
  1071.                 }
  1072.             }
  1073.             else {
  1074.                 /*  there are discriminants */
  1075.                 /*  the mode is na_out or na_inout */
  1076.                 /*  the formal is constrained, */
  1077.                 /*  the actual is unconstrained */
  1078.                 /*      parameter passing by copy ! */
  1079.                 gen_s(I_UPDATE_AND_DISCARD,
  1080.                   assoc_symbol_get(fname, FORMAL_TEMPLATE));
  1081.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS,
  1082.                   assoc_symbol_get(fname, ACTUAL_TEMPLATE));
  1083.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS,
  1084.                   assoc_symbol_get(fname, FORMAL_TEMPLATE));
  1085.                 gen_s(I_RECORD_MOVE, arg_type);
  1086.             }
  1087.         }
  1088.         else {
  1089.             compiler_error_s("Postlude, ftype =", ftype);
  1090.         }
  1091.     }
  1092.     tup_free(formals); 
  1093.     tup_free(actuals);
  1094. }
  1095.  
  1096. void gen_accept(Symbol entry_name, Node body_node, Node after_node)
  1097.                                                                 /*;gen_accept*/
  1098. {
  1099.     Tuple    formals;
  1100.     Symbol    fname, ftype, t_name;
  1101.     int        fmode;
  1102.     Fortup    ft1;
  1103.     int        save_last_offset;
  1104.  
  1105. #ifdef TRACE
  1106.     if (debug_flag)
  1107.         gen_trace_node("GEN_ACCEPT", body_node);
  1108. #endif
  1109.  
  1110.     formals          = SIGNATURE(entry_name);
  1111.     save_last_offset = LAST_OFFSET;
  1112.  
  1113.     /* preserve caller: */
  1114.     FORTUP(fname = (Symbol), formals, ft1);
  1115.         fmode = NATURE(fname);
  1116.         ftype = TYPE_OF(fname);
  1117.         if (is_array_type(ftype)) {
  1118.             /* Array addresses are mu_dble */
  1119.             t_name= new_unique_name("fname_type");
  1120.             assoc_symbol_put(fname, FORMAL_TEMPLATE, t_name);
  1121.             next_local_reference(t_name);
  1122.             gen_s(I_UPDATE_AND_DISCARD, t_name);
  1123.         }
  1124.         next_local_reference(fname);
  1125.         gen_s(I_UPDATE_AND_DISCARD, fname);
  1126.         if ((is_simple_type(ftype) && (fmode != na_in))) {
  1127.             /* scalar out and in out parameters take 2 stacks locations */
  1128.             /* one for returned na_out value, the other for temporary na_in */
  1129.             gen_ks(I_DISCARD_ADDR, 1, (Symbol)0);
  1130.         }
  1131.     ENDFORTUP(ft1);
  1132.  
  1133.     /* The body of the accept may contain a return statement, which should
  1134.      * be translated as an exit block followed by a jump to the end of
  1135.      * of the block. We set symbol_accept_return to the null case as an
  1136.      * initialization; this symbol will be set non-null if the accept
  1137.      * body contains a return, in which case we use it as the label
  1138.      * corresponding to the end of the body.
  1139.      */
  1140.     symbol_accept_return = (Symbol) 0; /* in case return within accept */
  1141.     if (body_node != OPT_NODE) {
  1142.         compile(body_node);
  1143.     }
  1144.  
  1145.     gen(I_END_RENDEZVOUS);
  1146.     symbol_accept_return = (Symbol) 0; /* reset */
  1147.  
  1148.     if (after_node != OPT_NODE) {
  1149.         compile(after_node);
  1150.     }
  1151.     /*MAX_OFFSET max= abs LAST_OFFSET;*/
  1152.     MAX_OFFSET = offset_max(MAX_OFFSET, LAST_OFFSET);
  1153.     LAST_OFFSET   = save_last_offset;
  1154. }
  1155.  
  1156. int offset_max(int m, int l)                                    /*;offset_max*/
  1157. {
  1158.     /* used to translate MAX_OFFSET max:= abs(LAST_OFFSET) */
  1159.     if (l < 0) l = -l;
  1160.     if (m < l) m = l;
  1161.     return m;
  1162. }
  1163.